home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / troper.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  8.6 KB  |  232 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module troper)
  13.  
  14.  
  15. (TRANSL-MODULE TROPER)
  16.  
  17. ;;; The basic OPERATORS properties translators.
  18.  
  19.  
  20. (declare-top (MUZZLED T)) ; TURN OFF CLOSED COMPILATION MESSAGE
  21.  
  22. (DEF%TR MMINUS (FORM)
  23.   (SETQ FORM (TRANSLATE (CADR FORM)))
  24.   (COND ((NUMBERP (CDR FORM))
  25.      `(,(CAR FORM) . ,(MINUS (CDR FORM))))
  26.     ((EQ '$FIXNUM (CAR FORM)) `($FIXNUM - ,(CDR FORM)))
  27.     ((EQ '$FLOAT (CAR FORM)) `($FLOAT -$ ,(CDR FORM)))
  28.     ((EQ '$NUMBER (CAR FORM)) `($NUMBER MINUS ,(CDR FORM)))
  29.     ((EQ '$RATIONAL (CAR FORM))
  30.      (COND ((AND (NOT (ATOM (CADDR FORM))) (EQ 'RAT (CAAR (CADDR FORM))))
  31.         (SETQ FORM (CDADDR FORM))
  32.         `($RATIONAL QUOTE ((RAT) ,(f- (CAR FORM)) ,(CADR FORM))))
  33.            (T `($RATIONAL RTIMES -1 ,(CDR FORM)))))
  34.     (T `($ANY . (*MMINUS ,(CDR FORM))))))
  35. (declare-top (MUZZLED NIL))
  36.  
  37. (DEF%TR MPLUS (FORM)
  38.   (LET   (ARGS MODE)
  39.     (DO ((L (CDR FORM) (CDR L))) ((NULL L))
  40.     (SETQ ARGS (CONS (TRANSLATE (CAR L)) ARGS)
  41.           MODE (*UNION-MODE (CAR (CAR ARGS)) MODE)))
  42.     (SETQ ARGS (NREVERSE ARGS))
  43.     (COND ((EQ '$FIXNUM MODE) `($FIXNUM f+ . ,(MAPCAR 'CDR ARGS)))
  44.       ((EQ '$FLOAT MODE) `($FLOAT +$ . ,(MAPCAR 'DCONV-$FLOAT ARGS)))
  45.       ((EQ '$RATIONAL MODE) `($RATIONAL RPLUS . ,(MAPCAR 'CDR ARGS)))
  46.       ((EQ '$NUMBER MODE) `($NUMBER PLUS . ,(MAPCAR 'CDR ARGS)))
  47.       (T `($ANY ADD* . ,(MAPCAR 'DCONVX ARGS))))))
  48.  
  49.  
  50. (DEFUN NESTIFY (OP L)
  51.   (DO ((L (CDR L) (CDR L)) (NL (CAR L))) ((NULL L) NL)
  52.       (SETQ NL (LIST OP NL (CAR L)))))
  53.  
  54. (DEF%TR MTIMES (FORM)
  55.   (LET
  56.    (ARGS MODE)
  57.    (COND
  58.     ((EQUAL -1 (CADR FORM))
  59.      (TRANSLATE `((MMINUS) ((MTIMES) . ,(CDDR FORM)))))
  60.     (t
  61.      (DO ((L (CDR FORM) (CDR L))) ((NULL L))
  62.      (SETQ ARGS (CONS (TRANSLATE (CAR L)) ARGS)
  63.            MODE (*UNION-MODE (CAR (CAR ARGS)) MODE)))
  64.      (SETQ ARGS (NREVERSE ARGS))
  65.      (COND ((EQ '$FIXNUM MODE) `($FIXNUM f* . ,(MAPCAR 'CDR ARGS)))
  66.        ((EQ '$FLOAT MODE) `($FLOAT *$ . ,(MAPCAR 'DCONV-$FLOAT ARGS)))
  67.        ((EQ '$RATIONAL MODE) `($RATIONAL RTIMES . ,(MAPCAR 'CDR ARGS)))
  68.        ((EQ '$NUMBER MODE) `($NUMBER TIMES . ,(MAPCAR 'CDR ARGS)))
  69.        (T `($ANY MUL* . ,(MAPCAR 'DCONVX ARGS))))))))
  70.  
  71.  
  72. (DEF%TR MQUOTIENT (FORM)
  73.     (let (ARG1 ARG2 MODE)
  74.          (SETQ ARG1 (TRANSLATE (CADR FORM)) ARG2 (TRANSLATE (CADDR FORM))
  75.            MODE (*UNION-MODE (CAR ARG1) (CAR ARG2))
  76.            ARG1 (DCONV ARG1 MODE) ARG2 (DCONV ARG2 MODE))
  77.          (COND ((EQ '$FLOAT MODE)
  78.             (SETQ ARG1 (IF (zl-MEMBER ARG1 '(1 1.0)) (LIST ARG2)
  79.                    (LIST ARG1 ARG2)))
  80.             `($FLOAT //$ . ,ARG1))
  81.            ((AND (EQ MODE '$FIXNUM) $TR_NUMER)
  82.             `($FLOAT . (//$ (FLOAT ,ARG1) (FLOAT ,ARG2))))
  83.            ((MEMQ MODE '($FIXNUM $RATIONAL))
  84.             `($RATIONAL RREMAINDER ,ARG1 ,ARG2))
  85.            (T `($ANY DIV ,ARG1 ,ARG2)))))
  86.  
  87. (defvar $tr_exponent nil "If True it allows translation of x^n to generate (expt $x $n) if $n is fixnum and $x is fixnum, or number" )
  88.  
  89. (DEF%TR MEXPT (FORM)
  90.   (IF (EQ '$%E (CADR FORM)) (TRANSLATE `(($EXP) ,(CADDR FORM)))
  91.       (LET   (BAS EXP)
  92.     (SETQ BAS (TRANSLATE (CADR FORM)) EXP (TRANSLATE (CADDR FORM)))
  93.     (COND ((EQ '$FIXNUM (CAR EXP))
  94.            (SETQ EXP (CDR EXP))
  95.            (COND ((EQ '$FLOAT (CAR BAS))
  96.               (COND ((NOT (INTEGERP EXP)) `($FLOAT ^$ ,(CDR BAS) ,EXP))
  97.                 (T `($FLOAT EXPT$ ,(CDR BAS) ,EXP))))
  98.              ((AND (EQ (CAR BAS) '$FIXNUM)
  99.                $TR_NUMER)
  100.               ;; when NUMER:TRUE we have 1/2 evaluating to 0.5
  101.               ;; therefore we have a TR_NUMER switch to control
  102.               ;; this form numerical hackers at translate time
  103.               ;; where it does the most good. -gjc
  104.               `($FLOAT . (^$ (FLOAT ,(CDR BAS)) ,EXP)))
  105.              ;; This next optimization was just plain wrong!
  106.              ;; -gjc
  107.              ;;((MEMQ (CAR BAS) '($FIXNUM $NUMBER))
  108.              ;;`($NUMBER EXPT ,(CDR BAS) ,EXP))
  109.              #+cl  ;;It seems to me we can do this,
  110.              ;; although 2^-3 would result in a "cl rat'l number"
  111.              ((and $tr_exponent (MEMQ (CAR BAS) '($FIXNUM $NUMBER)))
  112.              `($NUMBER EXPT ,(CDR BAS) ,EXP))
  113.              (T `($ANY POWER ,(CDR BAS) ,EXP))))
  114.           ((AND (EQ '$FLOAT (CAR BAS))
  115.             (EQ '$RATIONAL (CAR EXP))
  116.             (NOT (ATOM (CADDR EXP)))
  117.             (COND ((EQUAL 2 (CADDR (CADDR EXP)))
  118.                (SETQ EXP (CADR (CADDR EXP)))
  119.                (COND ((= 1 EXP) `($FLOAT SQRT ,(CDR BAS)))
  120.                  ((= -1 EXP) `($FLOAT //$ (SQRT ,(CDR BAS))))
  121.                  (T `($FLOAT EXPT$ (SQRT ,(CDR BAS)) ,EXP))))
  122.               ((EQ 'RAT (CAAR (CADDR EXP)))
  123.                `($FLOAT EXPT ,(CDR BAS) ,($FLOAT (CADDR EXP)))))))
  124.           ((AND (COVERS '$NUMBER (CAR BAS)) (COVERS '$NUMBER (CAR EXP)))
  125.            `(,(*UNION-MODE (CAR BAS) (CAR EXP)) EXPT ,(CDR BAS) ,(CDR EXP)))
  126.           (T `($ANY POWER ,(CDR BAS) ,(CDR EXP)))))))
  127.  
  128.  
  129.  
  130. (DEF%TR RAT (FORM) `($RATIONAL . ',FORM))
  131.  
  132. (DEF%TR BIGFLOAT (FORM) `($ANY . ',FORM))
  133.  
  134.  
  135.  
  136. (DEF%TR %SQRT (FORM)
  137.   (SETQ FORM (TRANSLATE (CADR FORM)))
  138.   (IF (EQ '$FLOAT (CAR FORM)) `($FLOAT SQRT ,(CDR FORM))
  139.       `($ANY SIMPLIFY (LIST '(%SQRT) ,(CDR FORM)))))
  140.  
  141. (DEF%TR MABS (FORM) 
  142.   (SETQ FORM (TRANSLATE (CADR FORM)))
  143.   (IF (COVERS '$NUMBER (CAR FORM)) (LIST (CAR FORM) 'ABS (CDR FORM))
  144.       `($ANY SIMPLIFY (LIST '(MABS) ,(DCONVX FORM)))))
  145.  
  146.  
  147. (DEF%TR %SIGNUM (FORM)
  148.     (LET (( (MODE . ARG) (TRANSLATE (CADR FORM))))
  149.          (COND ((MEMQ MODE '($FIXNUM $FLOAT))
  150.             (LET ((TEMP (TR-GENSYM)))
  151.              `($FIXNUM . ((LAMBDA (,TEMP)
  152.                           (DECLARE (,(IF (EQ MODE '$FLOAT)    
  153.                                  'flonum
  154.                                  'fixnum)
  155.                             ,TEMP))
  156.                           (COND ((MINUSP ,TEMP) -1)
  157.                             ((PLUSP ,TEMP) 1)
  158.                             (T 0)))
  159.                       ,ARG))))
  160.            (T
  161.             ;; even in this unknown case we can do a hell
  162.             ;; of a lot better than consing up a form to
  163.             ;; call the macsyma simplifier. I mean, shoot
  164.             ;; have a little SUBR called SIG-NUM or something.
  165.             `($ANY SIMPLIFY (LIST '(%SIGNUM) ,ARG))))))
  166.  
  167. ;; The optimization of using -1.0, +1.0 and 0.0 cannot be made unless we
  168. ;; know the TARGET MODE. The action of the simplifier is that
  169. ;; SIGNUM(3.3) => 1 , SIGNUM(3.3) does not give 0.0
  170. ;; Maybe this is a bug in the simplifier, maybe not. -gjc
  171.  
  172. ;; There are many possible non-trivial optimizations possible involving
  173. ;; SIGNUM. MODE TARGETTING must be built in to get these easily of course,
  174. ;; examples are: SIGNUM(X*Y); No need to multiple X and Y, just multiply
  175. ;; there SIGN's, which is a conditional and comparisons. However, these
  176. ;; are only optimizations if X and Y are numeric. What if
  177. ;; X:'a,Y:'B, ASSUME(A*B>0), SIGNUM(X*Y). Well, here
  178. ;; SIGNUM(X)*SIGNUM(Y) won't be the same as SIGNUM(X*Y). -gjc
  179.  
  180. ;; just to show the kind of brain damage...
  181. ;;(DEF%TR %SIGNUM (FORM)
  182. ;;   (SETQ FORM (TRANSLATE (CADR FORM)))
  183. ;;   (COND ((MEMQ (CAR FORM) 
  184. ;;      (LET   ((X (CDR FORM)) (MODE (CAR FORM))
  185. ;;            (ONE 1) (MINUS1 -1) (ZERO 0) (VAR '%%N)
  186. ;;            (DECLARE-TYPE 'FIXNUM) COND-CLAUSE)
  187. ;;         (IF (EQ '$FLOAT MODE) (SETQ ONE 1.0 MINUS1 -1.0 ZERO 0.0 VAR '$$X
  188. ;;                     DECLARE-TYPE 'FLONUM))
  189. ;;         (SETQ COND-CLAUSE `(COND ((MINUSP ,X) ,MINUS1)
  190. ;;                      ((PLUSP ,X)  ,ONE)
  191. ;;                      (T ,ZERO)))
  192. ;;         (IF (ATOM (CDR FORM)) `(,MODE . ,COND-CLAUSE)
  193. ;;         (ADDL `(,DECLARE-TYPE ,VAR) DECLARES)
  194. ;;         `(,MODE (LAMBDA (,VAR) ,COND-CLAUSE) ,X))))
  195. ;;     (T `($ANY SIMPLIFY (LIST '(%SIGNUM) ,(CDR FORM))))))
  196.  
  197.  
  198. (DEF%TR $ENTIER (FORM) 
  199.   (SETQ FORM (TRANSLATE (CADR FORM)))
  200.   (COND ((EQ '$FIXNUM (CAR FORM)) FORM)
  201.         ((MEMQ (CAR FORM) '($FLOAT $NUMBER))
  202.      (IF (EQ 'SQRT (CADR FORM)) `($FIXNUM $ISQRT ,(CADDR FORM))
  203.          `($FIXNUM FIX ,(CDR FORM))))
  204.         (T `(,(IF (EQ (CAR FORM) '$RATIONAL) '$FIXNUM '$ANY)
  205.           $ENTIER ,(CDR FORM)))))
  206.  
  207. (DEF%TR $FLOAT (FORM)
  208.   (SETQ FORM (TRANSLATE (CADR FORM)))
  209.   (IF (COVERS '$FLOAT (CAR FORM)) (CONS '$FLOAT (DCONV-$FLOAT FORM))
  210.       `($ANY $FLOAT ,(CDR FORM))))
  211.  
  212.  
  213.  
  214. (DEF%TR $EXP (FORM)
  215.   (SETQ FORM (TRANSLATE (CADR FORM)))
  216.   (IF (EQ '$FLOAT (CAR FORM)) `($FLOAT EXP ,(CDR FORM))
  217.       `($ANY SIMPLIFY ($EXP ,(CDR FORM)))))
  218.  
  219. (DEF%TR $ATAN2 (FORM)
  220.    (SETQ FORM (CDR FORM))
  221.    (LET   ((X (TRANSLATE (CAR FORM))) (Y (TRANSLATE (CADR FORM))))
  222.       (IF (EQ '$FLOAT (*UNION-MODE (CAR X) (CAR Y)))
  223.       `($FLOAT ATAN2 ,(CDR X) ,(CDR Y))
  224.     `($ANY SIMPLIFY (LIST '($ATAN2) ,(CDR X) ,(CDR Y))))))
  225.  
  226. (DEF%TR %ATAN (FORM)
  227.    (SETQ FORM (CDR FORM))
  228.    (LET   ((X (TRANSLATE (CAR FORM))))
  229.       (IF (EQ '$FLOAT (CAR X)) `($FLOAT ATAN1 ,(CDR X))
  230.       `($ANY SIMPLIFY (LIST '(%ATAN) ,(CDR X))))))
  231.  
  232.